(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
                     T)
         (LISPXPRIN1 (QUOTE " 1-FEB-73 23:20:51")
                     T)
         (LISPXTERPRI T))
(DEFINEQ

(VHASHSET
  [LAMBDA NIL
    (SETQ HCNILARRAY (CONS (HARRAY 100)
                           2.0))
    (SETQ HCARRAY (CONS (HARRAY 100)
                        2.0))
    (SETQ HNLARRAY (ARRAY 32))
    (MAPC (QUOTE (1.0 10000 ""))
          (FUNCTION (LAMBDA (X)
              (SETA HNLARRAY (NTYP X)
                    (LIST X])

(HCONS
  [LAMBDA (X Y)
    (COND
      [(NULL Y)
        (OR (GETHASH X HCNILARRAY)
            (PROG ((E (LIST X)))
                  (PUTHASH X E HCNILARRAY)
                  (RETURN E]
      (T (PROG ((D (GETHASH Y HCARRAY))
                E)
               (COND
                 ((NULL D)
                   (PUTHASH Y (LIST (SETQ D (CONS X Y)))
                            HCARRAY)
                   (RETURN D))
                 ((SETQ E (FASSOC X D))
                   (RETURN E))
                 (T (FRPLACD D (CONS (SETQ E (CONS X Y))
                                     (CDR D)))
                    (RETURN E])

(HNONL
  [LAMBDA (E)
    (PROG (L M)
          (COND
            ([SETQ M (MEMBER E (SETQ L (ELT HNLARRAY (NTYP E]
              (RETURN (CAR M)))
            (L (FRPLACD L (CONS E (CDR L)))
               (RETURN E))
            (T (HELP])

(HCONSP
  [LAMBDA (E)
    (COND
      [(NLISTP E)
        (OR (LITATOM E)
            (SMALLP E)
            (FMEMB E (ELT HNLARRAY (NTYP E]
      ((NULL (CDR E))
        (EQ (GETHASH (CAR E)
                     HCNILARRAY)
            E))
      (T (EQ (FASSOC (CAR E)
                     (GETHASH (CDR E)
                              HCARRAY))
             E])

(HLIST
  [LAMBDA K
    (PROG (L (N K))
      LP  (COND
            ((ZEROP N)
              (RETURN L)))
          (SETQ L (HCONS (ARG K N)
                         L))
          (SUB1VAR N)
          (GO LP])

(HCOPY
  [LAMBDA (E)
    (COND
      [(NLISTP E)
        (COND
          ((OR (LITATOM E)
               (SMALLP E))
            E)
          (T (HNONL E]
      ((HCONSP E)
        E)
      (T (HCONS (HCOPY (CAR E))
                (AND (SETQ E (CDR E))
                     (HCOPY E])

(HSUBLIS
  [LAMBDA (LIS X)
    (COND
      [(NLISTP X)
        (COND
          ((LITATOM X)
            (COND
              ((SETQ LIS (FASSOC X LIS))
                (CDR LIS))
              (T X)))
          ((SMALLP X)
            X)
          (T (HNONL X]
      (T (HCONS (HSUBLIS LIS (CAR X))
                (AND (SETQ X (CDR X))
                     (HSUBLIS LIS X])

(MK1
  [LAMBDA (OP L)
    (HCONS OP (HCOPY L])

(MK1*
  [LAMBDA K
    (PROG ((J K)
           L)
      LP  [COND
            ((EQ J 1)
              (RETURN (HCONS (ARG K 1)
                             L]
          (SETQ L (HCONS (HCOPY (ARG K J))
                         L))
          (SUB1VAR J)
          (GO LP])

(GSTART
  [LAMBDA NIL
    (SETQ *MARKER*(CONS T (GENSYM])

(RMARK
  [LAMBDA (E)
    (COND
      ((NOT (MARK E))
        (RMARK (CAR E))
        (RMARK (CDR E])

(MARK
  [LAMBDA (E)
    (COND
      ((NLISTP E))
      [(NULL (CDR E))
        (PROG ((D (GETHASH (CAR E)
                           HCNILARRAY)))
              (RETURN (COND
                        ((FMEMB *MARKER* D))
                        (D (PUTHASH (CAR E)
                                    (CONS *MARKER* E)
                                    HCNILARRAY)
                           NIL]
      (T (PROG ((D (GETHASH (CDR E)
                            HCARRAY))
                M N S)
               (COND
                 [(NULL (SETQ M (FMEMB *MARKER* D)))
                   (NCONC D (SETQ M (LIST *MARKER*]
                 ((FMEMB E (CDR M))
                   (RETURN T)))
               (COND
                 [(NULL (SETQ N (FMEMB E D]
                 ((EQ (SETQ S (CDR N))
                      M)
                   (FRPLACA M E)
                   (FRPLACA N *MARKER*))
                 (T (FRPLACA N (CAR S))
                    (FRPLACD N (CDR S))
                    (FRPLACA S E)
                    (FRPLACD S (CDR M))
                    (FRPLACD M S)))
               (RETURN NIL])

(GSWEEP
  [LAMBDA NIL
    (MAPCAR
      (QUOTE (HCNILARRAY HCARRAY))
      (FUNCTION (LAMBDA (NAME)
          (PROG ((N 0)
                 (M 0)
                 (Z (CAR NAME))
                 S)
                (SETQ S (ARRAYSIZE (CAR Z)))
                [MAPHASH1
                  Z
                  (FUNCTION (LAMBDA (P)
                      (PROG ((L (CAR P)))
                            (COND
                              (L (SETQ M (ADD1 M))
                                 (COND
                                   ((SETQ L (CDR (FMEMB *MARKER* L)))
                                     (SETQ N (ADD1 N))
                                     (FRPLACA P L))
                                   (T (PUTHASH (CDR P)
                                               NIL Z]
                [COND
                  ((ILESSP N (QUOTIENT S 4))
                    (SETQ N (CONS (HARRAY (ITIMES N 2))
                                  (CDR Z)))
                    (REHASH (CAR Z)
                            (CAR N))
                    (FRPLACA Z (CAR N]
                (RETURN (LIST NAME N M S])
)
  (LISPXPRINT (QUOTE VHASHFNS)
              T)
  (RPAQQ VHASHFNS
         (VHASHSET HCONS HNONL HCONSP HLIST HCOPY HSUBLIS MK1 MK1* 
                   GSTART RMARK MARK GSWEEP))
  (LISPXPRINT (QUOTE VHASHVARS)
              T)
  [RPAQQ VHASHVARS ((BLOCKS (MARKBLOCK MARK RMARK (ENTRIES RMARK))
                            (HSUBBLOCK HSUBLIS (ENTRIES HSUBLIS)))
          (ADDVARS (GLOBALVARS *MARKER* HCARRAY HCNILARRAY))
          (P (ENDLOAD (QUOTE VHASH]
(DECLARE
  (BLOCK: MARKBLOCK MARK RMARK (ENTRIES RMARK))
  (BLOCK: HSUBBLOCK HSUBLIS (ENTRIES HSUBLIS))
) (ADDTOVAR GLOBALVARS *MARKER* HCARRAY HCNILARRAY)
  (ENDLOAD (QUOTE VHASH))
STOP